home *** CD-ROM | disk | FTP | other *** search
/ Fifty: Elektronik / FIFTY Elektronik (PS_Computer_Vertrieb).iso / ps8 / fty1017 / gepackt.exe / DISK2 / PLOTSRC.EXE / PRNINOUT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-10  |  9.0 KB  |  399 lines
  1. Unit PrnInout;
  2.  
  3. interface
  4.  
  5. uses Dos,
  6.      Time,
  7.      StrTool,
  8.      SerInOut,
  9.      KeyScrn;
  10.  
  11. Const Devicename    : Str15   = 'Drucker';
  12.       IgnorePaperOut: Boolean = false;
  13.       TimeOut       : Byte    = 100;{50 sec bei XT }
  14.       TO_Versuche   : Word    = 1; { Time-Out-Versuche }
  15.  
  16. Var   NoError :Boolean;
  17.  
  18. procedure AssignAux(var F: Text; Port,BaudRate,StopBits,DataBits:byte;
  19.                     Parity :Paritytype);{96 =9600 Baud}
  20.  
  21. procedure AssignLST(Var F: Text; Port :Byte);
  22.  
  23. Procedure SetDeviceBinary(Var F:Text);
  24.  
  25.  
  26. implementation
  27. {$S-,R-}
  28.  
  29. type
  30.   TextBuf = array[0..127] of Char;
  31.   TextRec = record
  32.               Handle: Word;
  33.               Mode: Word;
  34.               BufSize: Word;
  35.               Private: Word;
  36.               BufPos: Word;
  37.               BufEnd: Word;
  38.               BufPtr: ^TextBuf;
  39.               OpenProc: Pointer;
  40.               InOutProc: Pointer;
  41.               FlushProc: Pointer;
  42.               CloseProc: Pointer;
  43.               PrnPort,PrnParam: Word;  { zwei neue Felder }
  44.               UserFill: array[1..12] of Byte; { um 4 Bytes kleiner }
  45.               Name: array[0..79] of Char;
  46.               Buffer: TextBuf;
  47.             end;
  48.  
  49. const
  50.   fmClosed = $D7B0;
  51.   fmInput  = $D7B1;
  52.   fmOutput = $D7B2;
  53.   fmInOut  = $D7B3;
  54.  
  55.   LPTermask :Byte=$39;
  56.  
  57.  
  58. VAR  Ok            :BOOLEAN;
  59.      Print_Error   :Boolean;
  60.      OldLPTtimeout :Byte;
  61.  
  62.  
  63. Procedure SetTimeOut(Time,Port:Byte;Serial:Boolean);
  64. Var T :LongInt;
  65. begin
  66.   If Serial then
  67.       SerTimeout:=Time
  68.   else
  69.   begin
  70.     oldLPTtimeout:=Mem[64:120+Port];
  71.     Mem[64:120+Port]:=Time;
  72.   end;
  73. end;
  74.  
  75. Procedure RestoreTimeOut(Port:Byte;Serial:Boolean);
  76. begin
  77.   If Not Serial then
  78.     Mem[64:120+Port]:=OldLPTtimeout;
  79. end;
  80.  
  81. FUNCTION OutError(Status:BYTE;Serial:Boolean):BOOLEAN;
  82.    Const Trie_Count:Word =0;
  83.    VAR StatusZeile : STR80;
  84.        Ch          : CHAR;
  85.    BEGIN
  86.         OutError := FALSE;
  87.         StatusZeile :=Devicename+': Unbekannter Fehler';
  88.         Inc(Trie_Count);
  89.         If Serial Then
  90.         begin
  91.         IF (Status and $80)<>0 THEN
  92.           begin
  93.             If Trie_Count<=TO_Versuche then Exit;
  94.             StatusZeile := 'Time Out Fehler des '+Devicename;
  95.           end;
  96.         end
  97.         else
  98.         begin
  99.         IF ((Status and $20)<>0) and Not(ignorepaperout) THEN
  100.            StatusZeile := Devicename+' hat kein Papier'
  101.           ELSE IF (Status and $10)=0 THEN
  102.                   StatusZeile :=  Devicename+' nicht Online'
  103.            ELSE IF (Status and $40)=0  THEN
  104.                    StatusZeile := 'Keine Reaktion des '+Devicename+'s'
  105.             ELSE IF (Status and $80)=0  THEN
  106.                     StatusZeile := Devicename+ ' beschäftigt'
  107.              ELSE IF (Status and $08)<>0 THEN
  108.                      StatusZeile := ' I/O Fehler des '+Devicename+'s'
  109.               ELSE IF (Status and $01)<>0 THEN
  110.                      begin
  111.                       If Trie_Count<=TO_Versuche then Exit;
  112.                       StatusZeile := ' Time Out Fehler des '+Devicename+'s';
  113.                      end;
  114.         end;
  115.         Trie_Count:=0;
  116.         CH:=SelectError(Statuszeile+' -> Abbrechen - Wiederholen ?'
  117.                         ,'Fehler:',['A','W']);
  118.         IF Ch='A' THEN begin NoError:=false;OutError:=True end;
  119.    END;
  120.  
  121. procedure AuxoutChar(C: Char);
  122. Var Error:Byte;
  123. begin
  124.      Ok:= Not(NoError);
  125.      WHILE NOT Ok DO
  126.          BEGIN
  127.            OutSerPort(Ord(C),Error);
  128.            If Error <>0
  129.              THEN Ok := OutError(Error,true)
  130.             ELSE Ok := TRUE;
  131.         END;
  132. end;
  133.  
  134.  
  135. {$F+}
  136.  
  137. function AuxOutput(var F: TextRec): Integer;
  138. var
  139.   P : Integer;
  140. begin
  141.   with F do
  142.   begin
  143.     If BufPos>0 then
  144.       begin
  145.         BufPos := 0;
  146.         AuxOutChar(BufPtr^[0]);
  147.       end;
  148.   end;
  149.   AuxOutput := 0;
  150. end;
  151.  
  152. function AuxIgnore(var F : TextRec) : Integer;
  153. begin
  154.   AuxIgnore := 0;
  155. end;
  156.  
  157. function AuxClose(var F : TextRec) : Integer;
  158. begin
  159.   RestoretimeOut(F.PrnPort,true);
  160.   AuxClose := 0;
  161. end;
  162.  
  163. function AuxOpen(var F : TextRec) : Integer;
  164. begin
  165.   with F do
  166.   begin
  167.     Noerror:=true;
  168.     if Mode = fmInput then
  169.     begin
  170.       InOutProc := @AuxIgnore;
  171.       FlushProc := @AuxIgnore;
  172.     end else
  173.     begin
  174.       Mode     := fmOutput;
  175.       InOutProc:= @AuxOutput;
  176.       FlushProc:= @AuxOutput;
  177.     end;
  178.     CloseProc := @AuxClose;
  179.   end;
  180.   AuxOpen := 0;
  181. end;
  182.  
  183. {$F-}
  184.  
  185. procedure AssignAux;
  186. var Param :Word;
  187. begin
  188.   Port:=Pred(Port) and 3;
  189.   SetSeriell(Port+1,Baudrate,Stopbits,Databits,Parity);
  190.   SetTimeOut(Timeout,Port,true);
  191.   with TextRec(F) do
  192.   begin
  193.     Handle    := $FFFF;
  194.     Mode      := fmClosed;
  195.     BufSize   := 1;
  196.     BufPtr    := @Buffer;
  197.     OpenProc  := @AuxOpen;
  198.     PrnPort   := Port;
  199.     PrnParam  := Param;
  200.     Name[0]   := #0;
  201.   end;
  202. end;
  203.  
  204.  
  205. PROCEDURE Print_INT17(Port :Word;C:CHAR); far; assembler;   { Neuer Druckertreiber }
  206.     ASM { Print }
  207.        MOV    AL,NoError
  208.        MOV    Print_Error,AL
  209. @@Test:OR     AL,AL
  210.        JE     @@fertig
  211.        XOR    AX,AX
  212.        MOV    Print_Error,AL
  213.        MOV    AL,C
  214.        MOV    DX,Port
  215.        INT    17H
  216.        MOV    AL,AH
  217.        XOR    AH,10H
  218.        AND    AH,LPTermask
  219.        JE     @@fertig
  220.        XOR    AH,AH
  221.        PUSH   AX
  222.        XOR    AX,AX
  223.        PUSH   AX
  224.        CALL   OutError
  225.        XOR    AL,1
  226.        MOV    Print_Error,AL
  227.        jmp    @@test
  228.   @@fertig:
  229. END; { Print }
  230.  
  231. (*  bringt keine Speedvorteile !!!!
  232. PROCEDURE Print_HW(Port :Word;C:CHAR);far; assembler;
  233. { Hier ist Port die Hardware-Portadresse und nicht die logische Adresse }
  234. ASM { Print_HW }
  235.        MOV    AL,NoError
  236.        MOV    Print_Error,AL
  237. @@Test:OR     AL,AL
  238.        JE     @@fertig
  239.        MOV    Print_Error,0
  240.        MOV    AL,C               { Zeichen in AL }
  241.        MOV    DX,Port            { Port-Adresse ins DX-Register}
  242.        OUT    DX,AL
  243.        MOV    BX,TimeOutCnt
  244.        MOV    Systimer,BX        { Systimer auf Timeout setzen }
  245.        INC    DX
  246. @@Wait:IN     AL, DX
  247.        and    Al,Al
  248.        js     @@is_ok           { Sign-Bit :Ok !!     }
  249.        CMP    SysTimer,0        { Systimer wird alle 1/18 sec dekrementiert}
  250.        JG     @@Wait            { >0 : Systimer noch nicht abgelaufen }
  251. @@TimeOut:
  252.        OR     AL,1
  253.        AND    AL,0F9H
  254.        jmp    @@stat
  255. @@is_Ok:
  256.        INC       DX
  257.        MOV    AL,0DH
  258.        CLI
  259.        OUT    DX,AL
  260.        nop
  261.        nop
  262.        jmp    @@A
  263. @@A:   jmp    @@B
  264. @@B:   MOV    AL,0CH
  265.        OUT    DX,AL   { Strobe-Impuls }
  266.        STI
  267.        nop
  268.        nop
  269.        nop
  270.        DEC    DX
  271.        IN     AL,DX
  272.        AND    AL,0F8H
  273. @@stat:XOR    AL,48H
  274.        MOV    AH,AL        { AH enthält Status ungefiltert }
  275.        XOR    AL,10H       { Invertiere OnLine-Bit }
  276.        AND    AL,LPTERMask { AL=0 :Status=ok}
  277. @@printed:
  278.        JE     @@fertig
  279.        MOV    AL,AH
  280.        XOR    AH,AH     { AX= Status }
  281.        PUSH   AX
  282.        XOR    AX,AX
  283.        PUSH   AX
  284.        CALL   OutError
  285.        XOR    AL,1
  286.        MOV    Print_Error,AL
  287.        jmp    @@test
  288.   @@fertig:
  289. END; { Print }
  290. *)
  291.  
  292. {$F+}
  293.  
  294. function LSTOutput(var F: TextRec):Integer; assembler;
  295. asm
  296.     LES DI,F
  297.     CMP TextRec(ES:[DI]).Bufpos,0
  298.     JE  @@Done
  299.     MOV  TextRec(ES:[DI]).Bufpos,0
  300.     PUSH TextRec(ES:[DI]).PrnPort
  301.     LES  DI,TextRec(ES:[DI]).BufPtr
  302.     PUSH WORD PTR ES:[DI]
  303.     CALL Print_INT17
  304. @@Done:
  305.     XOR AX,AX
  306. end;
  307. (*
  308. ** Pascal :
  309. function LSTOutput(var F: TextRec): Integer;
  310. begin
  311.   with F do
  312.   begin
  313.     If BufPos>0 then
  314.        PrintFunc(PrnPort,BufPtr^[0]);
  315.     BufPos := 0;
  316.   end;
  317.   LSTOutput := 0;
  318. end;
  319. *)
  320.  
  321.  
  322. function LSTIgnore(var F : TextRec) : Integer;
  323. begin
  324.   LSTIgnore := 0;
  325. end;
  326.  
  327. function LSTClose(var F : TextRec) : Integer;
  328. begin
  329.   RestoretimeOut(F.PrnPort,false);
  330.   LSTClose := 0;
  331. end;
  332.  
  333. function LSTOpen(var F : TextRec) : Integer;
  334. begin
  335.   If IgnorePaperout then
  336.     LPTermask:= $19 else LPTermask:=$39;
  337.   Noerror:=true;
  338.   with F do
  339.   begin
  340.     SetTimeOut(Timeout,PrnPort,false);
  341.     if Mode = fmInput then
  342.     begin
  343.       InOutProc := @LSTIgnore;
  344.       FlushProc := @LSTIgnore;
  345.     end else
  346.     begin
  347.       Mode     := fmOutput;
  348.       InOutProc:= @LSTOutput;
  349.       FlushProc:= @LSTOutput;
  350.     end;
  351.     CloseProc := @LSTClose;
  352.   end;
  353.   LSTOpen := 0;
  354. end;
  355.  
  356. {$F-}
  357.  
  358. procedure AssignLST;
  359. Var Direct:Boolean;
  360.  
  361. begin
  362.   Port:=Pred(Port);
  363.   IF Port>3 Then Port:=0;
  364.   with TextRec(F) do
  365.   begin
  366.     Handle    := $FFFF;
  367.     Mode      := fmClosed;
  368.     BufSize   := 1;
  369.     BufPtr    := @Buffer;
  370.     OpenProc  := @LSTOpen;
  371.     PrnPort:= Port;
  372.     PrnParam  := 0;
  373.     Name[0]   := #0;
  374.   end;
  375. end;
  376.  
  377. {$F+}
  378. Procedure SetDeviceBinary(Var F:Text);
  379. Var R:Registers;
  380. begin
  381.  
  382.   With TextRec(F) do
  383.    begin
  384.      If Handle=$FFFF then Exit;
  385.      R.AX:=$4400;
  386.      R.BX:=Handle;
  387.      MsDos(R);
  388.      If ((R.Flags and Fcarry)=0) and ((R.DX and $80)<>0) then
  389.       begin
  390.         R.DH:=0;
  391.         R.DL:=(R.DL and $EF) or $20;
  392.         R.AX:=$4401;
  393.         R.BX:=Handle;
  394.         MSDOS(R);
  395.       end;
  396.    end;
  397. end;
  398.  
  399. end.